home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1996 May: Tool Chest / Developer CD Series May 1996 (Tool Chest) (Apple Computer) (1996).iso / Tool Chest / Development Tools & Languages / Macintosh Common Lisp Related / 2.01 sources / Examples-2.01 / pict-scrap.lisp < prev    next >
Encoding:
Text File  |  1993-09-16  |  4.2 KB  |  131 lines  |  [TEXT/CCL2]
  1. ;;-*- Mode: Lisp; Package: CCL -*-
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;;
  4. ;;Pict-Scrap.Lisp
  5. ;;
  6. ;;Copyright © 1989, Apple Computer, Inc
  7. ;;
  8. ;;
  9. ;;  This file a scrap-handler for scraps of type PICT
  10. ;;
  11. ;;  Once this is installed, windows which copy and paste PICTs will
  12. ;;  be able to share their work with other applications
  13. ;;
  14. ;; Modified for 2.0 by Henry Lieberman
  15.  
  16. ;;;;;;;;;;;;
  17. ;;
  18. ;; Modification History
  19. ;;
  20. ;; 04/28/93 mwp Release
  21. ;; 04/24/92 bill Don't push multiple entries on *scrap-handler-alist*
  22. ;;               if loaded multiple times. Also, eliminate the memory
  23. ;;               leak in internalize-scrap (thanx to Bob Strong).
  24. ;; ------------- 2.0
  25. ;; 11/18/91 bill Don't need to require traps or records anymore.
  26. ;; 08/24/91 gb  Use new traps; don't use $applScratch
  27.  
  28. (in-package :ccl)
  29.  
  30. (defclass pict-scrap-handler (scrap-handler) ())
  31.  
  32. (defmethod set-internal-scrap ((self pict-scrap-handler) scrap)
  33.   (let* ((old-pict (slot-value self 'internal-scrap)))
  34.     (when (handlep old-pict)
  35.       (#_KillPicture old-pict)))        ;dispose of the old pict before we
  36.                                         ;put a new one in its place
  37.                                         ;this will crash if your program has
  38.                                         ;other pointers to the pict, so
  39.                                         ;always make sure cut/copy really do
  40.                                         ;-copy- the pict
  41.   (call-next-method self scrap)
  42.   (when scrap (pushnew :pict *scrap-state*)))
  43.  
  44. (defmethod externalize-scrap ((pict-scrap-handler pict-scrap-handler))
  45.   (let* ((the-pict (slot-value pict-scrap-handler 'internal-scrap))
  46.          (size (#_GetHandleSize the-pict)))
  47.     (when the-pict
  48.       (with-dereferenced-handles
  49.         ((the-pict the-pict))
  50.         (#_PutScrap size :pict the-pict)))))
  51.  
  52. (defmethod internalize-scrap ((self pict-scrap-handler))
  53.   (let* ((the-pict (slot-value self 'internal-scrap)))
  54.     (unless (handlep the-pict)
  55.       (setq the-pict
  56.             (setf (slot-value self 'internal-scrap)
  57.                    (#_NewHandle 0))))
  58.     (rlet ((junk :signed-long))
  59.       (#_GetScrap the-pict :pict junk))
  60.     the-pict))
  61.  
  62.  
  63. (defmethod get-internal-scrap ((pict-scrap-handler pict-scrap-handler))
  64.   (slot-value pict-scrap-handler 'internal-scrap))
  65.  
  66. (let ((p (assq :pict *scrap-handler-alist*)))
  67.   (if p 
  68.     (setf (cdr p) (make-instance 'pict-scrap-handler))
  69.     (push `(:pict . ,(make-instance 'pict-scrap-handler))
  70.           *scrap-handler-alist*)))
  71.  
  72. #|
  73. ;;;;;;;;;;;;;;;;;;;;;
  74. ;;
  75. ;; a simple window, supporting cut and paste with picts
  76. ;;
  77. ;; because it doesn't remember the picts which it pastes,
  78. ;; it can only cut a pseudo-pict, that is, a pict which
  79. ;; contains the window's current contents as a bitmap.
  80.  
  81. (defclass pict-window (window) ()
  82.   (:default-initargs 
  83.     :color-p t
  84.     :window-title "A Pict Window"))
  85.  
  86. (defmethod paste ((pict-window pict-window))
  87.   (let* ((pict (get-scrap :pict)))
  88.     (when pict
  89.       (with-port (wptr pict-window)
  90.         (rlet ((r :rect))
  91.           (with-dereferenced-handles ((pict-point pict))
  92.             (copy-record (rref pict-point :picture.picframe
  93.                                :storage :pointer)
  94.                          :rect
  95.                          r))
  96.         (#_DrawPicture pict r))))))
  97.  
  98. (defmethod copy ((pict-window pict-window))
  99.   (let* ((wptr (wptr pict-window)))
  100.     (rlet ((rect :rect 
  101.                  :left (rref wptr windowrecord.portrect.left)
  102.                  :top (rref wptr windowrecord.portrect.top)
  103.                  :right (rref wptr windowrecord.portrect.right)
  104.                  :bottom (rref wptr windowrecord.portrect.bottom)))
  105.       (with-port wptr
  106.         (#_cliprect rect)
  107.         (let* ((pict (#_OpenPicture rect))
  108.                (bits (rref wptr :windowrecord.portbits)))
  109.           (#_CopyBits 
  110.            bits 
  111.            bits 
  112.            rect 
  113.            rect 0        ;transfer mode
  114.            (%null-ptr))
  115.           (#_ClosePicture)
  116.           (put-scrap :pict pict))))))
  117.  
  118. (defmethod clear ((pict-window pict-window))
  119.   (let ((wptr (wptr pict-window)))
  120.     (with-port wptr
  121.       (#_EraseRect (rref wptr :windowrecord.portrect)))))
  122.  
  123. (defmethod cut ((pict-window pict-window))
  124.   (copy pict-window)
  125.   (clear pict-window))
  126.  
  127. (setq pw (make-instance 'pict-window))
  128.  
  129.  
  130. |#
  131.